Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue44/HTMLmove/Spritebx.pas

Pascal/Delphi Source File | 1997-08-28 | 8.4 KB | 305 lines

{ *****************************************************
                         TSpriteBox Component

  TSpriteBox is a TCustomControl derivative which has 2 offscreen
  bitmaps for sprite animation.

  TSpriteBox is designed to work with TSprite. Drop a TSprite
  on the form and watch it go!

                  Paul Warren
         HomeGrown Software Development
       (c) 1996 Langley British Columbia.
                [phone]
         e-mail:  [e-mail]
    Home page: http://haven.uniserve.com/~hg_soft
  ***************************************************** }

unit Spritebx;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, Sprites;

type
  TSpriteBox = class(TCustomControl)
  private
    { private declarations }
    FImage: TBitMap;
    FBackGnd1: TBitMap;
    FBackGnd2: TBitMap;
    FColor: TColor;
    FCenter: boolean;
    FStretch: boolean;
    FGradient: boolean;
    FBeforeSprtMove: TNotifyEvent;
    FAfterSprtMove: TNotifyEvent;
    procedure SetImage(AImage: TBitmap);
    procedure SetColor(Value: TColor);
    procedure SetCenter(Value: boolean);
    procedure SetStretch(Value: boolean);
    procedure SetGradient(Value: boolean);
    procedure SetBeforeSprtMove(Value: TNotifyEvent);
    procedure SetAfterSprtMove(Value: TNotifyEvent);
    procedure Loaded; override;
    procedure GradientFill(Color1, Color2: TColor);
    procedure DrawBMP;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { protected declarations }
    function GetPalette: HPALETTE; override;
    procedure HasChanged(Sender: TObject);
    procedure Paint; override;
  public
    { public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DrawSprite;
    property BackGnd1: TBitmap read FBackGnd1 write FBackGnd1;
    property BackGnd2: TBitmap read FBackGnd2 write FBackGnd2;
  published
    { published declarations }
    property Image: TBitmap read FImage write SetImage;
    property Color: TColor read FColor write SetColor default clBlack;
    property Center: boolean read FCenter write SetCenter default true;
    property Stretch: boolean read FStretch write SetStretch default false;
    property Gradient: boolean read FGradient write SetGradient default false;
    property BeforeSprtMove: TNotifyEvent read FBeforeSprtMove write SetBeforeSprtMove;
    property AfterSprtMove: TNotifyEvent read FAfterSprtMove write SetAfterSprtMove;
    property Align;
    property Visible;
    property OnClick;
  end;

procedure Register;

implementation

{$IFDEF WIN32}
  {$R SPRITEBX.D32}
{$ELSE}
  {$R SPRITEBX.D16}
{$ENDIF}

constructor TSpriteBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csOpaque, csDoubleClicks];
  FImage := TBitMap.Create;
  FBackGnd1 := TBitMap.Create;
  FBackGnd2 := TBitMap.Create;
  FCenter := true;
  FColor := clBlack;
  FStretch := false;
  FGradient := false;
  FImage.OnChange := HasChanged;
  Width := 105;
  Height := 105;
end;

destructor TSpriteBox.Destroy;
begin
  FImage.Free;
  FBackGnd1.Free;
  FBackGnd2.Free;
  inherited Destroy;
end;

procedure TSpriteBox.SetImage(AImage: TBitmap);
begin
  {Copy BackGnd image data from source bitmap}
  FImage.Assign(AImage);
end;

procedure TSpriteBox.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    DrawBMP;
  end;
end;

procedure TSpriteBox.SetCenter(Value: boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    DrawBMP;
  end;
end;

procedure TSpriteBox.SetStretch(Value: boolean);
begin
  if FStretch <> Value then
  begin
    FStretch := Value;
    DrawBMP;
  end;
end;

procedure TSpriteBox.SetGradient(Value: boolean);
begin
  if FGradient <> Value then
  begin
    FGradient := Value;
    DrawBMP;
  end;
end;

procedure TSpriteBox.SetBeforeSprtMove(Value: TNotifyEvent);
begin
  FBeforeSprtMove := Value;
end;

procedure TSpriteBox.SetAfterSprtMove(Value: TNotifyEvent);
begin
  FAfterSprtMove := Value;
end;

procedure TSpriteBox.Loaded;
begin
  { always call the inherited Loaded first! }
  inherited Loaded;
  DrawBMP;
end;

function TSpriteBox.GetPalette: HPALETTE;
begin
  Result := TBitmap(FBackGnd1).Palette;
end;

procedure TSpriteBox.HasChanged(Sender: TObject);
begin
  DrawBMP;
end;

procedure TSpriteBox.GradientFill(Color1, Color2: TColor);
var
  RGBFrom: array[0..2] of byte;
  RGBDiff: array[0..2] of integer;
  ColorBand: TRect;
  I: integer;
  R,G,B: Byte;
begin
  { extract from RGB values}
  RGBFrom[0] := GetRValue(ColorToRGB(Color1));
  RGBFrom[1] := GetGValue(ColorToRGB(Color1));
  RGBFrom[2] := GetBValue(ColorToRGB(Color1));
  { calculate difference of from and to RGB values}
  RGBDiff[0] := GetRValue(ColorToRGB(Color2)) - RGBFrom[0];
  RGBDiff[1] := GetGValue(ColorToRGB(Color2)) - RGBFrom[1];
  RGBDiff[2] := GetBValue(ColorToRGB(Color2)) - RGBFrom[2];
  { set color band's left and right coordinates}
  ColorBand.Left := 0;
  ColorBand.Right := Width;
  for I := 0 to $100 do
  begin
    { calculate color band's top and bottom coordinates}
    ColorBand.Top := MulDiv(I, Height, $100);
    ColorBand.Bottom := MulDiv(I + 1, Height, $100);
    { calculate color band color}
    R := RGBFrom[0] + MulDiv(I, RGBDiff[0], $ff);
    G := RGBFrom[1] + MulDiv(I, RGBDiff[1], $ff);
    B := RGBFrom[2] + MulDiv(I, RGBDiff[2], $ff);
    { select brush and paint color band}
    FBackGnd1.Canvas.Brush.Color := RGB(R, G, B);
    FBackGnd1.Canvas.FillRect(ColorBand);
  end;
end;

procedure TSpriteBox.DrawBMP;
var
  Dest: TRect;
begin
  { set size of BackGnd1 }
  FBackGnd1.Width := Width;
  FBackGnd1.Height := Height;
  { set brush color }
  FBackGnd1.Canvas.Brush.Color := FColor;
  { fill BackGnd1.Canvas }
  if FGradient then GradientFill(FColor,clBlack)
    else FBackGnd1.Canvas.FillRect(ClientRect);
  { if Image set then... }
  if (FImage.Width <> 0) and (FImage.Height <> 0) then
  begin
    { ...set Dest values... }
    if Stretch then
      Dest := ClientRect
    else if Center then
      Dest := Bounds((Width - FImage.Width) div 2, (Height - FImage.Height) div 2,
        FImage.Width, FImage.Height)
    else
      Dest := Rect(0, 0, FImage.Width, FImage.Height);
  end;
  { ...StretchDraw to BackGnd1.Canvas }
  FBackGnd1.Canvas.StretchDraw(Dest, FImage);
  { copy backgnd1 to backgnd2 }
  FBackGnd2.Assign(FBackGnd1);
  Invalidate;
end;

procedure TSpriteBox.DrawSprite;
var
  i, OldLeft, OldTop: integer;
begin
  for i := 0 to ControlCount-1 do
  begin
    if (Controls[i] is TSprite) and (Controls[i] as TSprite).Enabled then
    begin
      with (Controls[i] as TSprite) do
      begin
        if Assigned(FBeforeSprtMove) then BeforeSprtMove(Controls[i]);

        OldLeft := SLeft;
        OldTop := STop;

        MoveSprite;

        { Erase the old sprite in BackGnd2 }
        BitBlt(BackGnd2.Canvas.Handle, OldLeft-2, OldTop-2, Width+2, Height+2,
           BackGnd1.Canvas.Handle, OldLeft-2, OldTop-2, SrcCopy);

        { Draw the sprite at the new location in BackGnd2 }
        BitBlt(BackGnd2.Canvas.Handle, SLeft, STop, Width, Height,
           ANDImage.Canvas.Handle, 0, 0, SRCAND);
        BitBlt(BackGnd2.Canvas.Handle, SLeft, STop, Width, Height,
           ORImage.Canvas.Handle, 0, 0, SRCPAINT);

        { Copy a rectangle from BackGnd2 to reposition the sprite on the
          canvas }
        BitBlt(Canvas.Handle, OldLeft - 2, OldTop - 2, Width + 2, Height + 2,
           BackGnd2.Canvas.Handle, OldLeft - 2, OldTop - 2, SrcCopy);

        if Assigned(FAfterSprtMove) then AfterSprtMove(Controls[i]);
      end;
    end;
  end;
end;

{ Trap the Windows message requesting our size change,
  let it, then redraw }
procedure TSpriteBox.WMSize(var message: TWMSize);
begin
  inherited;
  if message.SizeType in [SIZE_MAXHIDE,SIZE_MAXSHOW] then
     Exit;  { Not our window that was resized }
  DrawBMP;
end;

procedure TSpriteBox.Paint;
begin
  Canvas.StretchDraw(ClientRect, FBackGnd1);
  if not (csDesigning in ComponentState) then DrawSprite;
end;

{ register component on Misc page }
procedure Register;
begin
  RegisterComponents('Misc', [TSpriteBox]);
end;

end.